(module heap mzscheme
  (provide 
   heap?
   make-heap
   make-heap/fn
   make-heap/implementation
   heap-empty?
   heap-insert
   heap-insert-all
   heap-merge
   heap-find-min
   heap-delete-min)
  
  (require (lib "etc.ss")
           (lib "list.ss")
           (lib "unitsig.ss")
           (lib "list.ss")
           "units/ordered.ss"
           "units/heap.ss")

  (define-struct fns (empty? insert insert-all merge find-min delete-min))
                             
  (define-struct tt (fns data))

  (define heap? tt?)

  (define make-heap
    (opt-lambda ([heap@ pairing-heap@]
                 [order@ numbers@])
      (use-heap (instantiate-heap heap@ order@))
      (make-tt (make-fns empty? insert insert-all merge find-min delete-min)
               empty)))
  
  (define make-heap/fn
    (opt-lambda (elm<
                 [heap@ pairing-heap@]
                 [elm= (lambda (a b) (and (not (elm< a b)) (not (elm< b a))))])
      (let ([_elm< elm<]
            [_elm= elm=]
            [_elm<= (lambda (a b) (or (elm< a b) (elm= a b)))])
      (make-heap 
       heap@ 
       (unit/sig ordered^
         (import)
         (define elm< _elm<)
         (define elm= _elm=)
         (define elm<= _elm<=))))))

  (define make-heap/implementation 
    (opt-lambda (elm<
                 empty empty? insert merge find-min delete-min
                 [elm= (lambda (a b) (and (not (elm< a b)) (not (elm< b a))))])

      (make-tt (make-fns empty? insert merge find-min delete-min)
               empty)))

  
  (define (invoke t field-fn . args)
    (make-tt (tt-fns t)
             (apply (field-fn (tt-fns t)) args)))

  (define (heap-empty? t) (invoke t fns-empty? (tt-data t)))
  (define (heap-insert t elm) (invoke t fns-insert (tt-data t) elm))
  (define (heap-insert-all t elms) (invoke t fns-insert-all (tt-data t) elms))
  (define (heap-merge a b) (invoke a fns-merge (tt-data a) (tt-data b)))
  (define (heap-find-min t) ((fns-find-min (tt-fns t)) (tt-data t)))
  (define (heap-delete-min t) (invoke t fns-delete-min (tt-data t)))

  (define (test)
    (printf "~a~n"
            (heap-find-min (heap-delete-min (heap-insert (make-heap/fn <) 2 3 1 4 5)))))

  (test)
)
